home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / w3dvb5 / lineanas.bas < prev    next >
BASIC Source File  |  1997-12-22  |  31KB  |  1,224 lines
  1. Attribute VB_Name = "Lineanas"
  2.  
  3. ' Modulo per l'eliminazione delle linee nascoste.
  4. '
  5. ' ATTENZIONE - La Sub LineNas Φ la routine principale
  6. '              di questo modulo e (sigh!) non funziona.
  7. '              Comunque altre routine e variabili presenti
  8. '              sono indispensabili per l'algoritmo del pittore
  9. '              che Φ funzionante. Ergo, non eliminate il modulo
  10. '              dal progetto! Non funzionerα pi∙ niente!
  11.  
  12.  
  13. Public AlgoritmoAttivo As Integer ' 0 - Pittore, 1 - Linenas (serve per Orienta)
  14.  
  15. Public Const Nscreen = 10  '  // Ci saranno Nscreen x Nscreen quadrati
  16. Public density As Double
  17.  
  18. Public d As Double
  19. Public c1 As Double
  20. Public c2 As Double
  21. Public xfactor As Double
  22. Public yfactor As Double
  23.  
  24. Public Xrange As Double
  25. Public Yrange As Double
  26. Public Xvp_range As Double
  27. Public Yvp_range As Double
  28.  
  29. Public xmin As Double
  30. Public xmax As Double
  31. Public ymin As Double
  32. Public ymax As Double
  33. Public zmin As Double
  34. Public zmax As Double
  35.  
  36. Public deltax As Double
  37. Public deltay As Double
  38. Public denom As Double
  39. 'Public zemin As Double
  40. 'Public zemax As Double
  41.  
  42. Public eps1 As Double
  43. Public trset() As Integer
  44. Public dummy As Integer
  45. Public vertexcount As Integer
  46.  
  47. Public x_center As Double
  48. Public y_center As Double
  49. Public r_max As Double
  50. Public x_max As Double
  51. Public y_max As Double
  52. Public x_min As Double
  53. Public y_min As Double
  54.  
  55. Type Vertexes
  56.      Vt As Vec_Int
  57.      Z As Double
  58.      Connect(5) As Integer
  59. End Type
  60.  
  61. Public VV() As Vertexes
  62. Public pVertex As Integer
  63.  
  64. Type Nodo
  65.   idx As Integer
  66.   jtr As Integer
  67.   nextn As Integer
  68. End Type
  69.  
  70. Public VScreen(Nscreen, Nscreen) As Nodo
  71.  
  72. Type Point
  73.   Pntscr As Vec_Int
  74.   zPnt As Double
  75.   nrPnt As Integer
  76. End Type
  77.  
  78. Type linked_stack
  79.     p As Point
  80.     q As Point
  81.     k0 As Integer
  82.     nextn As Integer
  83. End Type
  84.     
  85. Public stptr(1) As linked_stack
  86.  
  87.  
  88. Sub add_linesegment(Pr As Integer, Qr As Integer)
  89. Dim iaux As Integer
  90. Dim p As Integer
  91. Dim i As Integer
  92. Dim n As Integer
  93. Dim Pt(3) As Integer
  94. Dim p_old(3) As Integer
  95. Dim Pnr As Integer
  96. Dim Qnr As Integer
  97.  
  98.  Pnr = Pr
  99.  Qnr = Qr
  100.   
  101.  
  102.    If (Pnr > Qnr) Then
  103.       iaux = Pnr
  104.       Pnr = Qnr
  105.       Qnr = iaux
  106.    End If
  107.    
  108.  ' Ora: Pnr < Qnr
  109.    p = VV(Pnr).Connect(0)
  110.    If (p = 0) Then
  111.        VV(Pnr).Connect(0) = 1
  112.        VV(Pnr).Connect(1) = Qnr
  113.        Exit Sub
  114.    End If
  115.    
  116.    n = VV(Pnr).Connect(0)
  117.    For i = 1 To n
  118.       If VV(Pnr).Connect(i) = Qnr Then Exit Sub ' Giα nella lista
  119.    Next i
  120.    
  121.    n = n + 1 ' Ora Q deve essere posto in p[n]
  122.    If (n Mod 3 = 0) Then
  123.       p_old(0) = VV(Pnr).Connect(0)
  124.       p_old(1) = VV(Pnr).Connect(1)
  125.       p_old(2) = VV(Pnr).Connect(2)
  126.     
  127.     ' Blocchi di tre interi
  128.       For i = 1 To n - 1
  129.           VV(Pnr).Connect(i) = p_old(i)
  130.       Next
  131.       VV(Pnr).Connect(0) = n
  132.       VV(Pnr).Connect(n) = Qnr '  // n Φ un multiplo di 3
  133.                                '  // *p=n, p[1],..., p[n] usati
  134.                                '  // (p[n+1], p[n+2] liberi)
  135.    Else
  136.       VV(Pnr).Connect(0) = n
  137.       VV(Pnr).Connect(n) = Qnr ' // n non Φ un multiplo di 3 (e n > 1)
  138.    End If
  139.  
  140.  
  141. End Sub
  142.  
  143. Function ColNr(x As Integer) As Integer
  144.          ColNr = (CLng(x) * Nscreen) / LARGE1
  145. End Function
  146.  
  147. Sub dealwithlinkedstack()
  148.  
  149. Dim Pt As linked_stack
  150. Dim p As Point
  151. Dim q As Point
  152. Dim k0 As Integer
  153. Dim Ptr As Integer
  154.  
  155. Ptr = 1
  156. Do While Ptr <> 0
  157.     Pt = stptr(Ptr)
  158.     p = Pt.p
  159.     q = Pt.q
  160.     k0 = Pt.k0
  161.     Ptr = Pt.nextn
  162.     linesegment Form1.Pict, p, q, k0
  163. Loop
  164.  
  165.  
  166. End Sub
  167.  
  168.  
  169. Sub LineNas(Pic As PictureBox)
  170.  
  171. Dim i As Integer
  172. Dim Pnr As Integer
  173. Dim Qnr As Integer
  174. Dim ii As Integer
  175. Dim vertexnr As Integer
  176. Dim Ptr As Integer
  177. Dim iconnect As Integer
  178. Dim code As Integer
  179. Dim ntr As Integer
  180. Dim i_i As Integer
  181. Dim j_j As Integer
  182. Dim jtop As Integer
  183. Dim jbot As Integer
  184. Dim jI As Integer
  185. Dim trnr As Integer
  186. Dim jtr As Integer
  187. Dim Poly() As Integer
  188. Dim nPoly As Integer
  189. Dim iLeft As Integer
  190. Dim iRight As Integer
  191. Dim nvertex As Integer
  192. Dim ntrset As Integer
  193. Dim maxntrset As Integer
  194. Dim VLOWER(Nscreen) As Integer
  195. Dim VUPPER(Nscreen) As Integer
  196. Dim Orient As Integer
  197. Dim maxnpoly As Integer
  198. Dim totntria As Integer
  199. Dim testtria(3) As Integer
  200.  
  201. Dim xsmin As Double
  202. Dim xsmax As Double
  203. Dim ysmin As Double
  204. Dim ysmax As Double
  205.  
  206.  
  207. Dim nrs_tr() As Trianrs
  208.  
  209. Dim deltax As Long
  210. Dim deltay As Long
  211.  
  212. Dim rho As Double
  213. Dim Theta As Double
  214. Dim Phi As Double
  215. Dim x As Double
  216. Dim Y As Double
  217. Dim Z As Double
  218. Dim xe As Double
  219. Dim ye As Double
  220. Dim ze As Double
  221. Dim xx As Double
  222. Dim yy As Double
  223. Dim fx As Double
  224. Dim fy As Double
  225. Dim Xcenter As Double
  226. Dim Ycenter As Double
  227.  
  228. Dim Ps As Vec_Int
  229. Dim Qs As Vec_Int
  230. Dim vLeft As Vec_Int
  231. Dim vRight As Vec_Int
  232.  
  233. Dim p As Vec3
  234.  
  235. Dim pNode As Integer
  236.  
  237. minvertex = 32000
  238. maxntrset = 400
  239. AlgoritmoAttivo = 1 ' Per Funct. Orienta
  240.  
  241. Erase stptr
  242.  
  243.  
  244.    nvertex = MaxVertNr + 1
  245.    ReDim Vt(nvertex)
  246.    
  247.    SetVista rho, Theta, Phi
  248.    SetLimitiVista xsmin, xsmax, ysmin, ysmax, nvertex, Vt()
  249.  
  250. ' Da InitGr
  251.    
  252.    x_max = 10
  253.    density = X__max / (x_max - x_min)
  254.    y_max = y_min + Y__max / density
  255.    x_center = 0.5 * (x_min + x_max)
  256.    y_center = 0.5 * (y_min + y_max)
  257.  
  258.    zfactor = LARGE / (zemax - zemin)
  259.    eps1 = 0.001 * (zemax - zemin)
  260.    
  261. '   // Calcola le costanti del video:
  262.    
  263.    Xrange = xsmax - xsmin
  264.    Yrange = ysmax - ysmin
  265.    
  266.    Xvp_range = x_max - x_min
  267.    Yvp_range = y_max - y_min
  268.    fx = Xvp_range / Xrange
  269.    fy = Yvp_range / Yrange
  270.    If fx < fy Then
  271.       d = 0.95 * fx
  272.    Else
  273.       d = 0.95 * fy
  274.    End If
  275.    
  276.    Xcenter = 0.5 * (xsmin + xsmax)
  277.    Ycenter = 0.5 * (ysmin + ysmax)
  278.    c1 = x_center - d * Xcenter
  279.    c2 = y_center - d * Ycenter
  280.    deltax = Xrange / Nscreen
  281.    deltay = Yrange / Nscreen
  282.    
  283.    xfactor = LARGE / Xrange
  284.    yfactor = LARGE / Yrange
  285.    
  286.    
  287.    
  288.    ReDim VV(nvertex)
  289.    
  290. ' Inizializza l'array dei vertici:
  291.    
  292.    For i = 0 To nvertex
  293.       If Vt(i).Z < -100000# Then
  294.          Erase VV(i).Connect
  295.       Else
  296.          Erase VV(i).Connect
  297.          VV(i).Vt.x = xIntScr(Vt(i).x / Vt(i).Z, xsmin)
  298.          VV(i).Vt.Y = yIntScr(Vt(i).Y / Vt(i).Z, ysmin)
  299.          VV(i).Z = Vt(i).Z
  300.   '       MsgBox "x= " & VV(i).Vt.X & "y= " & VV(i).Vt.Y & "z= " & VV(i).Z
  301.        End If
  302.   Next i
  303.   
  304.   Erase Vt
  305.  
  306. ' Trova il numero massimo di vertici in un solo poligono
  307. ' e il numero totale dei triangoli che non sono
  308. ' retrosuperfici:
  309.    
  310. maxnpoly = 0
  311. totntria = 0
  312.          
  313. nPoly = 0
  314. For k = 1 To UBound(FileVertex)
  315.  nPoly = 0
  316.  i = Abs(FileVertex(k).Vert(1))
  317.  If i > 0 Then
  318.     For j = 1 To FileVertex(k).Count
  319.         i = Abs(FileVertex(k).Vert(j))
  320.               
  321.         If i >= nvertex Then
  322.            MsgBox "Vertice nr." & CStr(i) & " indefinito"
  323.            End
  324.         End If
  325.         If nPoly < 3 Then testtria(nPoly) = i
  326.     
  327.         nPoly = nPoly + 1
  328.     Next j
  329.          
  330.          If (nPoly > maxnpoly) Then maxnpoly = nPoly
  331.          If Not (nPoly < 3) Then  '  // Ignora il segmento 'libero'
  332.             If (orienta(testtria(0), testtria(1), testtria(2)) >= 0) Then totntria = totntria + nPoly - 2
  333.          End If
  334.        
  335.  End If
  336.           
  337. Next k
  338.          
  339.          
  340. ' =========
  341.  
  342.   ReDim Triangles(totntria)
  343.   ReDim Poly(maxnpoly)
  344.   ReDim nrs_tr(maxnpoly - 2)
  345.  
  346.  
  347. '   // Lettura delle facce dell'oggetto e memorizzazione dei
  348. '   // triangoli:
  349.    
  350.    
  351. For k = 1 To UBound(FileVertex)
  352.          
  353.     nPoly = 0
  354.     For j = 1 To FileVertex(k).Count
  355.         
  356.         i = Abs(FileVertex(k).Vert(j))
  357.         If nPoly = maxnpoly Then
  358.            MsgBox "Errore di programmazione maxnpoly"
  359.            End
  360.         End If
  361.         Poly(nPoly) = i
  362.         nPoly = nPoly + 1
  363.     
  364.     Next j
  365.     
  366.    
  367.   '  If (nPoly = 1) Then
  368.       '  MsgBox "Solo un vertice del poligono?"
  369.       '  End
  370.   '  End If
  371.     
  372.     If nPoly = 2 Then
  373.       Call add_linesegment(Poly(0), Poly(1))
  374.     Else
  375.     
  376.        Pnr = Abs(Poly(0))
  377.        Qnr = Abs(Poly(1))
  378.        For s = 2 To nPoly - 1
  379.           Orient = LOrienta(Pnr, Qnr, Abs(Poly(s)))
  380.           If (Orient